home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tk8.0 / tests / visual.test < prev    next >
Encoding:
Text File  |  1997-08-15  |  9.3 KB  |  313 lines  |  [TEXT/ALFA]
  1. # This file is a Tcl script to test the visual- and colormap-handling
  2. # procedures in the file tkVisual.c.  It is organized in the standard
  3. # fashion for Tcl tests.
  4. #
  5. # Copyright (c) 1994 The Regents of the University of California.
  6. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  7. #
  8. # See the file "license.terms" for information on usage and redistribution
  9. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  10. #
  11. # SCCS: @(#) visual.test 1.11 96/02/16 10:55:34
  12.  
  13. if {[info procs test] != "test"} {
  14.     source defs
  15. }
  16.  
  17. foreach i [winfo children .] {
  18.     destroy $i
  19. }
  20. wm geometry . {}
  21. raise .
  22. update
  23.  
  24. # eatColors --
  25. # Creates a toplevel window and allocates enough colors in it to
  26. # use up all the slots in the colormap.
  27. #
  28. # Arguments:
  29. # w -        Name of toplevel window to create.
  30.  
  31. proc eatColors {w} {
  32.     catch {destroy $w}
  33.     toplevel $w
  34.     wm geom $w +0+0
  35.     canvas $w.c -width 400 -height 200 -bd 0
  36.     pack $w.c
  37.     for {set y 0} {$y < 8} {incr y} {
  38.     for {set x 0} {$x < 40} {incr x} {
  39.         set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0]
  40.         $w.c create rectangle [expr 10*$x] [expr 20*$y] \
  41.             [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \
  42.             -fill $color
  43.     }
  44.     }
  45.     update
  46. }
  47.  
  48. # colorsFree --
  49. #
  50. # Returns 1 if there appear to be free colormap entries in a window,
  51. # 0 otherwise.
  52. #
  53. # Arguments:
  54. # w -            Name of window in which to check.
  55. # red, green, blue -    Intensities to use in a trial color allocation
  56. #            to see if there are colormap entries free.
  57.  
  58. proc colorsFree {w {red 31} {green 245} {blue 192}} {
  59.     set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]]
  60.     expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \
  61.         && ([lindex $vals 2]/256 == $blue)
  62. }
  63.  
  64. # If more than one visual type is available for the screen, pick one
  65. # that is *not* the default.
  66.  
  67. set default "[winfo visual .] [winfo depth .]"
  68. set avail [winfo visualsavailable .]
  69. set other {}
  70. if {[llength $avail] > 1} {
  71.     foreach visual $avail {
  72.     if {$visual != $default} {
  73.         set other $visual
  74.         break
  75.     }
  76.     }
  77. }
  78.  
  79. test visual-1.1 {Tk_GetVisual, copying from other window} {
  80.     list [catch {toplevel .t -visual .foo.bar} msg] $msg
  81. } {1 {bad window path name ".foo.bar"}}
  82. if {$other != ""} {
  83.     test visual-1.2 {Tk_GetVisual, copying from other window} {nonPortable} {
  84.     catch {destroy .t1}
  85.     catch {destroy .t2}
  86.     toplevel .t1 -width 250 -height 100 -visual $other
  87.     wm geom .t1 +0+0
  88.     toplevel .t2 -width 200 -height 80 -visual .t1
  89.     wm geom .t2 +5+5
  90.     concat "[winfo visual .t2] [winfo depth .t2]"
  91.     } $other
  92.     test visual-1.3 {Tk_GetVisual, copying from other window} {
  93.     catch {destroy .t1}
  94.     catch {destroy .t2}
  95.     toplevel .t1 -width 250 -height 100 -visual $other
  96.     wm geom .t1 +0+0
  97.     toplevel .t2 -width 200 -height 80 -visual .
  98.     wm geom .t2 +5+5
  99.     concat "[winfo visual .t2] [winfo depth .t2]"
  100.     } $default
  101.  
  102.     # Make sure reference count is incremented when copying visual (the
  103.     # following test will cause the colormap to be freed prematurely if
  104.     # the reference count isn't incremented).
  105.     test visual-1.4 {Tk_GetVisual, colormap reference count} {
  106.     catch {destroy .t1}
  107.     catch {destroy .t2}
  108.     toplevel .t1 -width 250 -height 100 -visual $other
  109.     wm geom .t1 +0+0
  110.     set result [list [catch {toplevel .t2 -gorp 80 -visual .t1} msg] $msg]
  111.     update
  112.     set result
  113.     } {1 {unknown option "-gorp"}}
  114. }
  115. test visual-1.5 {Tk_GetVisual, default colormap} {
  116.     catch {destroy .t1}
  117.     toplevel .t1 -width 250 -height 100 -visual default
  118.     wm geometry .t1 +0+0
  119.     update
  120.     concat "[winfo visual .t1] [winfo depth .t1]"
  121. } $default
  122.  
  123. set i 1
  124. foreach visual $avail {
  125.     test visual-2.$i {Tk_GetVisual, different visual types} {nonPortable} {
  126.     catch {destroy .t1}
  127.     toplevel .t1 -width 250 -height 100 -visual $visual
  128.     wm geometry .t1 +0+0
  129.     update
  130.     concat "[winfo visual .t1] [winfo depth .t1]"
  131.     } $visual
  132.     incr i
  133. }
  134.  
  135. test visual-3.1 {Tk_GetVisual, parsing visual string} {
  136.     catch {destroy .t1}
  137.     toplevel .t1 -width 250 -height 100 \
  138.         -visual "[winfo visual .][winfo depth .]"
  139.     wm geometry .t1 +0+0
  140.     update
  141.     concat "[winfo visual .t1] [winfo depth .t1]"
  142. } $default
  143. test visual-3.2 {Tk_GetVisual, parsing visual string} {
  144.     catch {destroy .t1}
  145.     list [catch {
  146.     toplevel .t1 -width 250 -height 100 -visual goop20
  147.     wm geometry .t1 +0+0
  148.     } msg] $msg
  149. } {1 {unknown or ambiguous visual name "goop20": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}}
  150. test visual-3.3 {Tk_GetVisual, parsing visual string} {
  151.     catch {destroy .t1}
  152.     list [catch {
  153.     toplevel .t1 -width 250 -height 100 -visual d
  154.     wm geometry .t1 +0+0
  155.     } msg] $msg
  156. } {1 {unknown or ambiguous visual name "d": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}}
  157. test visual-3.4 {Tk_GetVisual, parsing visual string} {
  158.     catch {destroy .t1}
  159.     list [catch {
  160.     toplevel .t1 -width 250 -height 100 -visual static
  161.     wm geometry .t1 +0+0
  162.     } msg] $msg
  163. } {1 {unknown or ambiguous visual name "static": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default}}
  164. test visual-3.5 {Tk_GetVisual, parsing visual string} {
  165.     catch {destroy .t1}
  166.     list [catch {
  167.     toplevel .t1 -width 250 -height 100 -visual "pseudocolor 48x"
  168.     wm geometry .t1 +0+0
  169.     } msg] $msg
  170. } {1 {expected integer but got "48x"}}
  171.  
  172. if {$other != ""} {
  173.     catch {destroy .t1}
  174.     catch {destroy .t2}
  175.     catch {destroy .t3}
  176.     toplevel .t1 -width 250 -height 100 -visual $other
  177.     wm geom .t1 +0+0
  178.     toplevel .t2 -width 200 -height 80 -visual [winfo visual .]
  179.     wm geom .t2 +5+5
  180.     toplevel .t3 -width 150 -height 250 -visual [winfo visual .t1]
  181.     wm geom .t3 +10+10
  182.     test visual-4.1 {Tk_GetVisual, numerical visual id} nonPortable {
  183.     list [winfo visualid .t2] [winfo visualid .t3]
  184.     } [list [winfo visualid .] [winfo visualid .t1]]
  185.     destroy .t1 .t2 .t3
  186. }
  187. test visual-4.2 {Tk_GetVisual, numerical visual id} {
  188.     catch {destroy .t1}
  189.     list [catch {toplevel .t1 -visual 12xyz} msg] $msg
  190. } {1 {bad X identifier for visual: 12xyz"}}
  191. test visual-4.3 {Tk_GetVisual, numerical visual id} {
  192.     catch {destroy .t1}
  193.     list [catch {toplevel .t1 -visual 1291673} msg] $msg
  194. } {1 {couldn't find an appropriate visual}}
  195.  
  196. if ![string match *pseudocolor* $avail] {
  197.     test visual-5.1 {Tk_GetVisual, no matching visual} {
  198.     catch {destroy .t1}
  199.     list [catch {
  200.         toplevel .t1 -width 250 -height 100 -visual "pseudocolor 8"
  201.         wm geometry .t1 +0+0
  202.     } msg] $msg
  203.     } {1 {couldn't find an appropriate visual}}
  204. }
  205.  
  206. if {[string match *pseudocolor* $avail] && ([llength $avail] > 1)} {
  207.     test visual-6.1 {Tk_GetVisual, no matching visual} {nonPortable} {
  208.     catch {destroy .t1}
  209.     toplevel .t1 -width 250 -height 100 -visual "best"
  210.     wm geometry .t1 +0+0
  211.     update
  212.     winfo visual .t1
  213.     } {pseudocolor}
  214. }
  215.  
  216. # These tests are non-portable due to variations in how many colors
  217. # are already in use on the screen.
  218.  
  219. if {([winfo visual .] == "pseudocolor") && ([winfo depth .] == 8)} {
  220.     eatColors .t1
  221.     test visual-7.1 {Tk_GetColormap, "new"} {nonPortable} {
  222.     toplevel .t2 -width 30 -height 20
  223.     wm geom .t2 +0+0
  224.     update
  225.     colorsFree .t2
  226.     } {0}
  227.     test visual-7.2 {Tk_GetColormap, "new"} {nonPortable} {
  228.     catch {destroy .t2}
  229.     toplevel .t2 -width 30 -height 20 -colormap new
  230.     wm geom .t2 +0+0
  231.     update
  232.     colorsFree .t2
  233.     } {1}
  234.     test visual-7.3 {Tk_GetColormap, copy from other window} {nonPortable} {
  235.     catch {destroy .t2}
  236.     toplevel .t3 -width 400 -height 50 -colormap new
  237.     wm geom .t3 +0+0
  238.     catch {destroy .t2}
  239.     toplevel .t2 -width 30 -height 20 -colormap .t3
  240.     wm geom .t2 +0+0
  241.     update
  242.     destroy .t3
  243.     colorsFree .t2
  244.     } {1}
  245.     test visual-7.4 {Tk_GetColormap, copy from other window} {nonPortable} {
  246.     catch {destroy .t2}
  247.     toplevel .t3 -width 400 -height 50 -colormap new
  248.     wm geom .t3 +0+0
  249.     catch {destroy .t2}
  250.     toplevel .t2 -width 30 -height 20 -colormap .
  251.     wm geom .t2 +0+0
  252.     update
  253.     destroy .t3
  254.     colorsFree .t2
  255.     } {0}
  256.     test visual-7.5 {Tk_GetColormap, copy from other window} {nonPortable} {
  257.     catch {destroy .t1}
  258.     list [catch {toplevel .t1 -width 400 -height 50 \
  259.         -colormap .choke.lots} msg] $msg
  260.     } {1 {bad window path name ".choke.lots"}}
  261.     if {$other != {}} {
  262.     test visual-7.6 {Tk_GetColormap, copy from other window} {nonPortable} {
  263.         catch {destroy .t1}
  264.         catch {destroy .t2}
  265.         toplevel .t1 -width 300 -height 150 -visual $other
  266.         wm geometry .t1 +0+0
  267.         list [catch {toplevel .t2 -width 400 -height 50 \
  268.             -colormap .t1} msg] $msg
  269.     } {1 {can't use colormap for .t1: incompatible visuals}}
  270.     }
  271.     catch {destroy .t1}
  272.     catch {destroy .t2}
  273. }
  274.  
  275. test visual-8.1 {Tk_FreeColormap procedure} {
  276.     foreach w [winfo child .] {
  277.     destroy $w
  278.     }
  279.     toplevel .t1 -width 300 -height 180 -colormap new
  280.     wm geometry .t1 +0+0
  281.     foreach i {.t2 .t3 .t4} {
  282.     toplevel $i -width 250 -height 150 -colormap .t1
  283.     wm geometry $i +0+0
  284.     }
  285.     destroy .t1
  286.     destroy .t3
  287.     destroy .t4
  288.     update
  289. } {}
  290. if {$other != {}} {
  291.     test visual-8.2 {Tk_FreeColormap procedure} {
  292.     foreach w [winfo child .] {
  293.         destroy $w
  294.     }
  295.     toplevel .t1 -width 300 -height 180 -visual $other
  296.     wm geometry .t1 +0+0
  297.     foreach i {.t2 .t3 .t4} {
  298.         toplevel $i -width 250 -height 150 -visual $other
  299.         wm geometry $i +0+0
  300.     }
  301.     destroy .t2
  302.     destroy .t3
  303.     destroy .t4
  304.     update
  305.     } {}
  306. }
  307.  
  308. foreach w [winfo child .] {
  309.     destroy $w
  310. }
  311. rename eatColors {}
  312. rename colorsFree {}
  313.